home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / vbtime1a / idbas_sy.bas < prev    next >
Encoding:
BASIC Source File  |  1999-09-19  |  13.9 KB  |  413 lines
  1. Attribute VB_Name = "IDBAS_SystemInformation"
  2. Option Explicit
  3.  
  4. Const FO_COPY = &H2
  5. Const FO_MOVE = &H1
  6. Const FO_RENAME = &H4
  7.  
  8. Const FOF_SILENT = &H4
  9. Const FOF_NOCONFIRMATION = &H10
  10. Const FOF_FILESONLY = &H80
  11. Const FOF_SIMPLEPROGRESS = &H100
  12. Const FOF_NOCONFIRMMKDIR = &H200
  13.  
  14. Const SHARD_PATH = &H2&
  15.  
  16. Type SHFILEOPSTRUCT
  17.   hWnd      As Long
  18.   wFunc      As Long
  19.   pFrom      As String
  20.   pTo        As String
  21.   fFlags     As Integer
  22.   fAborted   As Boolean
  23.   hNameMaps  As Long
  24.   sProgress  As String
  25. End Type
  26.  
  27. Private Declare Function GetModuleFileName Lib "KERNEL32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
  28. Private Declare Function SHAddToRecentDocs Lib "shell32.dll" (ByVal dwFlags As Long, ByVal dwData As String) As Long
  29. Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
  30. Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
  31. Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
  32. Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  33. Private Declare Function GetComputerName Lib "KERNEL32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
  34.  
  35. Type tSystemInfo
  36.      dwOemID As Long
  37.      dwPageSize As Long
  38.      lpMinimumApplicationAddress As Long
  39.      lpMaximumApplicationAddress As Long
  40.      dwActiveProcessorMask As Long
  41.      dwNumberOrfProcessors As Long
  42.      dwProcessorType As Long
  43.      dwAllocationGranularity As Long
  44.      dwReserved As Long
  45.  End Type
  46.  
  47.  Type tOsVersionInfo
  48.      dwOSVersionInfoSize As Long
  49.      dwMajorVersion As Long
  50.      dwMinorVersion As Long
  51.      dwBuildNumber As Long
  52.      dwPlatformId As Long
  53.      szCSDVersion As String * 128
  54.  End Type
  55.  
  56.  Type tMemoryStatus
  57.      dwLength As Long
  58.      dwMemoryLoad As Long
  59.      dwTotalPhys As Long
  60.      dwAvailPhys As Long
  61.      dwTotalPageFile As Long
  62.      dwAvailPageFile As Long
  63.      dwTotalVirtual As Long
  64.      dwAvailVirtual As Long
  65.  End Type
  66.  
  67.  Enum eOsVersion
  68.     Windows32s = 0
  69.     Windows95 = 1
  70.     WindowsNT = 2
  71.  End Enum
  72.  
  73. 'The following three Declare lines must be each entered on a single
  74. 'line.
  75. Declare Function GetVersionEx Lib "KERNEL32" Alias "GetVersionExA" (LpVersionInformation As tOsVersionInfo) As Long
  76. Declare Sub GlobalMemoryStatus Lib "KERNEL32" (lpBuffer As tMemoryStatus)
  77. Declare Sub GetSystemInfo Lib "KERNEL32" (lpSystemInfo As tSystemInfo)
  78.  
  79. Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
  80.  
  81. Const PROCESSOR_INTEL_386 = 386
  82. Const PROCESSOR_INTEL_486 = 486
  83. Const PROCESSOR_INTEL_PENTIUM = 586
  84. Const PROCESSOR_MIPS_R4000 = 4000
  85. Const PROCESSOR_ALPHA_21064 = 21064
  86.  
  87. Private Const GWL_WNDPROC = (-4)
  88. Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
  89. Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
  90. Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
  91. Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  92. Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  93. Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  94. Declare Sub GetLocalTime Lib "KERNEL32" (lpSystemTime As SystemTime)
  95.  
  96. Type SystemTime
  97.         wYear As Integer
  98.         wMonth As Integer
  99.         wDayOfWeek As Integer
  100.         wDay As Integer
  101.         wHour As Integer
  102.         wMinute As Integer
  103.         wSecond As Integer
  104.         wMilliseconds As Integer
  105. End Type
  106.  
  107. Dim msg As String         ' Status information.
  108. Dim NewLine As String     ' New-line.
  109. Dim ret As Integer        ' OS Information
  110. Dim ver_major As Integer  ' OS Version
  111. Dim ver_minor As Integer  ' Minor Os Version
  112. Dim Build As Long         ' OS Build
  113. Dim verinfo As tOsVersionInfo
  114. Dim sysinfo As tSystemInfo
  115. Dim memsts As tMemoryStatus
  116. Dim memory As Long
  117. Dim OsType As eOsVersion
  118.  
  119.  
  120. Function SystemInformation() As String
  121.  
  122.       NewLine = Chr(13) + Chr(10)  ' New-line.
  123.        ' Get operating system and version.
  124.       verinfo.dwOSVersionInfoSize = Len(verinfo)
  125.       ret = GetVersionEx(verinfo)
  126.       If ret = 0 Then
  127.           MsgBox "Error Getting Version Information"
  128.           Exit Function
  129.       End If
  130.  
  131.       Select Case verinfo.dwPlatformId
  132.           Case 0
  133.               msg = msg + "Windows 32s "
  134.               OsType = Windows32s
  135.           Case 1
  136.               msg = msg + "Windows 95 "
  137.               OsType = Windows95
  138.           Case 2
  139.               msg = msg + "Windows NT "
  140.               OsType = WindowsNT
  141.       End Select
  142.  
  143.       ver_major = verinfo.dwMajorVersion
  144.       ver_minor = verinfo.dwMinorVersion
  145.       Build = verinfo.dwBuildNumber
  146.       msg = msg & ver_major & "." & ver_minor
  147.       msg = msg & " (Build " & Build & ")" & NewLine & NewLine
  148.  
  149.       ' Get CPU type and operating mode.
  150.       GetSystemInfo sysinfo
  151.       msg = msg + "CPU: "
  152.       Select Case sysinfo.dwProcessorType
  153.           Case PROCESSOR_INTEL_386
  154.               msg = msg + "Intel 386" + NewLine
  155.           Case PROCESSOR_INTEL_486
  156.               msg = msg + "Intel 486" + NewLine
  157.           Case PROCESSOR_INTEL_PENTIUM
  158.               msg = msg + "Intel Pentium" + NewLine
  159.           Case PROCESSOR_MIPS_R4000
  160.               msg = msg + "MIPS R4000" + NewLine
  161.           Case PROCESSOR_ALPHA_21064
  162.               msg = msg + "DEC Alpha 21064" + NewLine
  163.           Case Else
  164.               msg = msg + "(unknown)" + NewLine
  165.       End Select
  166.  
  167.       msg = msg + NewLine
  168.  
  169.       ' Get free memory.
  170.       GlobalMemoryStatus memsts
  171.       memory = memsts.dwTotalPhys
  172.       msg = msg + "Total Physical Memory: "
  173.       msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
  174.       memory = memsts.dwAvailPhys
  175.       msg = msg + "Available Physical Memory: "
  176.       msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
  177.       memory = memsts.dwTotalVirtual
  178.       msg = msg + "Total Virtual Memory: "
  179.       msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
  180.       memory = memsts.dwAvailVirtual
  181.       msg = msg + "Available Virtual Memory: "
  182.       msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
  183.  
  184.       SystemInformation = msg
  185. End Function
  186.  
  187. Public Function OperatingSystemVersion() As eOsVersion
  188.     Call SystemInformation
  189.     OperatingSystemVersion = OsType
  190. End Function
  191. Public Function UserName() As String
  192. Dim lpBuff As String * 25
  193. Dim ret As Long
  194.     ret = GetUserName(lpBuff, 25)
  195.     UserName = LCase(Left(lpBuff, InStr(lpBuff, Chr(0)) - 1))
  196. End Function
  197.  
  198. Public Function CreateShortCut(ByVal shortCutName As String, ByVal fileName As String, Optional ByVal commandLineArgs As String, Optional ByVal shortCutLocation As String = "Start Menu", Optional ByVal allUsers As Boolean = True, Optional ByVal VB5 As Boolean = True) As Boolean
  199. Dim pathString
  200. Dim pos As Integer
  201.  
  202.     If VB5 = False Then
  203.         Dim wShell As Object
  204.         Dim wShortcut As Object
  205.         
  206.         Set wShell = CreateObject("WScript.Shell")
  207.     
  208.         If OperatingSystemVersion = WindowsNT Then
  209.             If allUsers = True Then
  210.                 pathString = Environ("WINDIR") & "\Profiles" & "\All Users"
  211.             Else
  212.                 pathString = Environ("WINDIR") & "\Profiles" & "\" & UserName
  213.             End If
  214.         Else
  215.             pathString = Environ("WINDIR")
  216.         End If
  217.         pathString = pathString & "\" & shortCutLocation & "\" & shortCutName & ".lnk"
  218.         
  219.         If Dir(pathString) = "" Then
  220.             On Error GoTo e_Trap
  221.             Set wShortcut = wShell.CreateShortCut(pathString)
  222.             wShortcut.TargetPath = fileName & " " & commandLineArgs
  223.             wShortcut.Save
  224.             On Error GoTo 0
  225.         End If
  226.         CreateShortCut = True
  227.         
  228.         Exit Function
  229.     Else
  230.         Dim r As Long
  231.         Dim folderPath As String
  232.                
  233.         If OperatingSystemVersion = WindowsNT Then
  234.             If allUsers = True Then
  235.                 pathString = Environ("WINDIR") & "\Profiles" & "\All Users"
  236.             Else
  237.                 pathString = Environ("WINDIR") & "\Profiles" & "\" & UserName
  238.             End If
  239.             folderPath = Environ("WINDIR") & "\Profiles" & "\" & UserName & "\Recent"
  240.         Else
  241.             pathString = Environ("WINDIR")
  242.             folderPath = Environ("WINDIR") & "\Recent"
  243.         End If
  244.         pathString = pathString & "\" & shortCutLocation & "\" & shortCutName & ".lnk"
  245.    
  246.         If Dir(pathString) = "" Then
  247.         
  248.             r = SHAddToRecentDocs(SHARD_PATH, fileName)
  249.             DoEvents
  250.             DoEvents
  251.       
  252.             pos = InStrRev(fileName, "\", , vbTextCompare)
  253.     
  254.             If MoveShortCut(folderPath & "\" & Mid(fileName, pos + 1, Len(fileName) - pos) & ".lnk", pathString) = False Then
  255.                 CreateShortCut = False
  256.             Else
  257.                 CreateShortCut = True
  258.             End If
  259.         Else
  260.             CreateShortCut = True
  261.         End If
  262.         Exit Function
  263.    End If
  264.    Exit Function
  265. e_Trap:
  266.     CreateShortCut = False
  267.     Exit Function
  268.     
  269. End Function
  270. Public Function RemoveShortCut(ByVal shortCutName As String, Optional ByVal shortCutLocation As String = "Start Menu", Optional ByVal allUsers As Boolean = True) As Boolean
  271. Dim pathString
  272.  
  273.     If OperatingSystemVersion = WindowsNT Then
  274.         If allUsers = True Then
  275.             pathString = Environ("WINDIR") & "\Profiles" & "\All Users"
  276.         Else
  277.             pathString = Environ("WINDIR") & "\Profiles" & "\" & UserName
  278.         End If
  279.     Else
  280.         pathString = Environ("WINDIR")
  281.     End If
  282.     pathString = pathString & "\" & shortCutLocation & "\" & shortCutName & ".lnk"
  283.     
  284.     On Error GoTo e_Trap
  285.     Call Kill(pathString)
  286.     On Error GoTo 0
  287.     RemoveShortCut = True
  288.     Exit Function
  289. e_Trap:
  290.     RemoveShortCut = False
  291.     Exit Function
  292. End Function
  293. Public Function CopyShortCut(ByVal sourceFile As String, ByVal destinationFile As String) As Boolean
  294. 'working variables
  295.  Dim sFiles As String
  296.  Dim SHFileOp As SHFILEOPSTRUCT
  297.     
  298.     On Error GoTo e_Trap
  299.     'terminate passed strings with a null
  300.      sourceFile = sourceFile & Chr$(0)
  301.      destinationFile = destinationFile & Chr$(0)
  302.     
  303.     'set up the options
  304.      With SHFileOp
  305.        .wFunc = FO_COPY
  306.        .pFrom = sourceFile
  307.        .pTo = destinationFile
  308.        .fFlags = FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOCONFIRMMKDIR
  309.      End With
  310.      
  311.     'and perform the copy
  312.     Call SHFileOperation(SHFileOp)
  313.     DoEvents
  314.     DoEvents
  315.     If Dir(destinationFile) <> "" Then
  316.         CopyShortCut = True
  317.     Else
  318.         CopyShortCut = False
  319.     End If
  320.     Exit Function
  321. e_Trap:
  322.     CopyShortCut = False
  323.     Exit Function
  324. End Function
  325. Public Function MoveShortCut(ByVal sourceFile As String, ByVal destinationFile As String) As Boolean
  326. 'working variables
  327.  Dim sFiles As String
  328.  Dim SHFileOp As SHFILEOPSTRUCT
  329.     
  330.     On Error GoTo e_Trap
  331.     DoEvents
  332.     DoEvents
  333.     'terminate passed strings with a null
  334.      sourceFile = sourceFile & Chr$(0)
  335.      destinationFile = destinationFile & Chr$(0)
  336.     
  337.     'set up the options
  338.      With SHFileOp
  339.        .wFunc = FO_MOVE
  340.        .pFrom = sourceFile
  341.        .pTo = destinationFile
  342.        .fFlags = FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOCONFIRMMKDIR
  343.      End With
  344.      
  345.     'and perform the copy
  346.     Call SHFileOperation(SHFileOp)
  347.     If Dir(destinationFile) <> "" Then
  348.         MoveShortCut = True
  349.     Else
  350.         MoveShortCut = False
  351.     End If
  352.     Exit Function
  353. e_Trap:
  354.     MoveShortCut = False
  355.     Exit Function
  356. End Function
  357.  
  358.  
  359. Public Property Get DebugMode() As Boolean
  360. Dim strFileName As String
  361. Dim lngCount As Long
  362.     strFileName = String(255, 0)
  363.     lngCount = GetModuleFileName(App.hInstance, strFileName, 255)
  364.     strFileName = Left(strFileName, lngCount)
  365.     If UCase(Right(strFileName, 7)) <> "VB6.EXE" Then
  366.         DebugMode = False
  367.     Else
  368.         DebugMode = True
  369.     End If
  370. End Property
  371.  
  372. Public Sub StopPrevInstance()
  373. Dim Result&
  374. Dim OldWindowProc As Long  ' Original window proc
  375.     
  376.     Result = EnumWindows(AddressOf EnumWindowsProc, 0&)
  377.     Call SetWindowLong(App.hInstance, GWL_WNDPROC, OldWindowProc)
  378.  
  379. End Sub
  380.  
  381. Private Function EnumWindowsProc(ByVal hWnd&, lParam&) As Long
  382. Dim WndName As String * 255
  383. Dim FoundhWnd As Long
  384. Dim Result&
  385. Const WM_QUIT = &H12
  386.  
  387.     Result = GetWindowText(hWnd, WndName, 254&)
  388.     If Left(WndName, InStr(1, WndName, vbNullChar) - 1) = App.Title Then
  389.         FoundhWnd = hWnd
  390.         If DebugMode = False And App.hInstance <> FoundhWnd Then
  391.             Call MsgBox("Kill em all!")
  392.             Call PostMessage(FoundhWnd, WM_QUIT, 0&, 0&)
  393.         End If
  394.     End If
  395.     
  396.     EnumWindowsProc = True
  397. End Function
  398. Public Property Get getTime() As Double
  399. Dim currentTime As SystemTime
  400.     Call GetLocalTime(currentTime)
  401.     getTime = (currentTime.wHour * CLng(3600000) + currentTime.wMinute * CLng(60000) + currentTime.wSecond * CLng(1000) + currentTime.wMilliseconds) / CLng(1000)
  402.     Exit Property
  403. End Property
  404.  
  405. Public Function ComputerName() As String
  406. Dim compname As String
  407. Dim ret As Long
  408.     compname = Space(255)  ' set a large enough buffer for the computer name
  409.     ret = GetComputerName(compname, 255)  ' get the computer's name
  410.     ComputerName = UCase(Left(compname, InStr(compname, vbNullChar) - 1))
  411. End Function
  412.  
  413.